MacFormat 1995 September/macformat-028.iso/mac/Shareware City/Applications/ezGenes 0.2 PPC/Source 0.2/UFile.p

Text File | 1995-06-10 | 7.8 KB | 393 lines | [TEXT/MWPS]

unit UFile;

interface

    uses
{$IFC undefined THINK_Pascal}
        TextUtils,
{$ENDC}
        UObject;

    type

        FileUsage = (kDisk, kPermMem, kTempMem, kClipboard);

        TGenericFile = object(TObject)

                fref: integer;
                fSize, fPos: longint;

                procedure TGenericFile.IGenericFile (RefNum: integer);

                function TGenericFile.EndOfFile: Boolean;

                procedure TGenericFile.SetFilePos (N: longint);

                procedure TGenericFile.GetFilePos (var N: longint);

                procedure TGenericFile.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: INTEGER));
                OVERRIDE;
            end;


        TTextFile = object(TGenericFile)

                fBuffer: handle;
                fUsage: FileUsage;

                procedure TTextFile.ITextFile (RefNum: integer; usage: FileUsage);

                procedure TTextFile.Free;
                OVERRIDE;
                procedure TTextFile.ShallowRead (addr: ptr; var N: longint);    {Private}

                procedure TTextFile.SkipTo (ch: char);

                function TTextFile.NextLine: str255;

                function TTextFile.NextNumber: longint;

                procedure TTextFile.WriteLine (S: str255);

                procedure TTextFile.SetFilePos (N: longint);
                OVERRIDE;
                procedure TTextFile.GetFilePos (var N: longint);
                OVERRIDE;
                procedure TTextFile.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: INTEGER));
                OVERRIDE;
            end;


        TRecordFile = object(TGenericFile)

                fRecSize: integer;

                procedure TRecordFile.IRecordFile (RefNum, RecSiz: integer);

                procedure TRecordFile.Seek (N: longint);

                procedure TRecordFile.ReadRec (addr: ptr);

                procedure TRecordFile.WriteRec (addr: ptr);

                procedure TRecordFile.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: INTEGER));
                OVERRIDE;
            end;

{$IFC defined THINK_Pascal}
    function TempNewHandle (logicalSize: Size; var resultCode: OSErr): Handle;
    INLINE $3F3C, $001D, $A88F;

    procedure TempDisposeHandle (h: Handle; var resultCode: OSErr);
    INLINE $3F3C, $0020, $A88F;
{$ENDC}


implementation

    uses
{SysEqu, Traps, PrintTraps, ULoMem, UPatch, UObject, UViewCoords, UMacAppUtilities, }
        UMemory, UFailure;


{$S AFile}
    procedure TGenericFile.IGenericFile (RefNum: integer);
        var
            N: longint;
    begin
        fRef := RefNum;
        FailOSErr(GetEof(fRef, N));
        fSize := N;
        fPos := 0;
{$IFC qDebug}
        writeln('File: ', fSize : 6, fPos : 3);
{$ENDC}
    end;

    function TGenericFile.EndOfFile: Boolean;
    begin
        EndOfFile := (fPos >= fSize)
    end;

    procedure TGenericFile.SetFilePos (N: longint);
    begin
        FailOSErr(SetFPos(fRef, fsFromStart, N));
        fPos := N
    end;

    procedure TGenericFile.GetFilePos (var N: longint);
    begin
        FailOSErr(GetFPos(fRef, N));
        fPos := N
    end;


{  procedure TTextFile.ITextFile (RefNum: integer; Buffered: Boolean); }
{   var }
{    N: longint; }
{  begin }
{   IGenericFile(RefNum); }
{   N := fSize; }
{   if Buffered then }
{    fBuffer := NewPermHandle(N) }
{   else }
{    fBuffer := nil; }
{   if fBuffer <> nil then }
{    FailOSErr(FSRead(fRef, N, fBuffer^)); }
{  end; }

    procedure TTextFile.ITextFile (RefNum: integer; usage: FileUsage);
        var
            N: longint;
            h: Handle;
            offset: LONGINT;
            savedPerm: BOOLEAN;
            err: integer;
    begin
        fUsage := usage;
        fBuffer := nil;
        if usage = kClipboard then
            begin
                h := NewPermHandle(0);
                FailNIL(h);
                savedPerm := PermAllocation(TRUE);
                N := GetScrap(h, 'TEXT', offset);
                savedPerm := PermAllocation(savedPerm);
                if N < 0 then
                    FailOSErr(N);
                fBuffer := h;
                fRef := 0;
                fSize := N;
                fPos := 0;
            end
        else
            begin
                IGenericFile(RefNum);
                N := fSize;
                case usage of
                    kDisk:
                        ;
                    kPermMem:
                        begin
                            fBuffer := NewPermHandle(N);
{$IFC qDebug}
                            writeln('  Perm Buffer: ', MemError, fBuffer <> nil);
{$ENDC}
                        end;
                    kTempMem:
                        begin
                            if gConfiguration.systemVersion >= $700 then
                                fBuffer := TempNewHandle(N, err);
{$IFC qDebug}
                            writeln('  Temp Buffer: ', err, '  ', fBuffer <> nil);
{$ENDC}
                        end;
                end;
                if fBuffer = nil then
                    fUsage := kDisk
                else
                    FailOSErr(FSRead(fRef, N, fBuffer^));
            end;
    end;

    procedure TTextFile.Free;
        OVERRIDE;
        var
            err: integer;
    begin
        case fUsage of
            kDisk:
                ;
            kPermMem, kClipboard:
                if fBuffer <> nil then
{$IFC defined THINK_Pascal}
                    DisposHandle(fBuffer);
{$ELSEC}
                    DisposeHandle(fBuffer);
{$ENDC}
            kTempMem:
                begin
                    TempDisposeHandle(fBuffer, err);
{$IFC qDebug}
                    writeln('  Disp Buffer: ', err, '  ', fBuffer = nil);
{$ENDC}
                end;
        end;
        inherited Free;
    end;

{  procedure TTextFile.Free; }
{   OVERRIDE; }
{  begin }
{   if fBuffer <> nil then }
{    DisposHandle(fBuffer); }
{   inherited Free; }
{  end; }

    procedure TTextFile.ShallowRead (addr: ptr; var N: longint);
    begin
        if fBuffer <> nil then
            begin
                BlockMove(ptr(ord(fBuffer^) + fPos), addr, N);
            end
        else
            begin
                FailOSErr(FSRead(fRef, N, addr));
            end;
        SetFilePos(fPos + N);
    end;

    procedure TTextFile.SkipTo (ch: char);
        var
            S: str255;
            N, p: longint;
            k: integer;
    begin
        repeat
            N := min(fSize - fPos, 255);
            p := fPos;
            ShallowRead(@S[1], N);
            k := 0;
            repeat
                k := k + 1
            until (S[k] = ch) or (k = N);
        until (S[k] = ch) or EndOfFile;
        SetFilePos(p + k);
    end;

    function TTextFile.NextLine: str255;
        var
            S: str255;
            k, p1, p2: longint;
    begin
        p1 := fPos;
        SkipTo(chReturn);
        p2 := fPos;
        k := min(p2 - p1 - 1, 255);
        if k > 0 then
            begin
                SetFilePos(p1);
                ShallowRead(@S[1], k);
            end;
        S[0] := chr(k);
        NextLine := S;
        SetFilePos(p2);
    end;

    function TTextFile.NextNumber: longint;
        var
            X: str255;
            k: integer;
            p, N: longint;
    begin
        p := fPos;
        X := NextLine;
        k := 1;
        while (k < length(X)) & (X[k] in [' ', chTab]) do
            k := k + 1;
        while (k < length(X)) & (X[k] in ['0'..'9']) do
            k := k + 1;
        X[0] := chr(k - 1);
        if k > 1 then
            StringToNum(X, N)
        else
            N := 0;
        NextNumber := N;
        SetFilePos(p + k - 1);
    end;

    procedure TTextFile.WriteLine (S: str255);
        var
            N: longint;
    begin
        if fBuffer <> nil then
            FailOSErr(111);
        N := length(S);
        FailOSErr(FSWrite(fRef, N, @S[1]));
        N := 1;
        S[1] := chReturn;
        FailOSErr(FSWrite(fRef, N, @S[1]));
        GetFilePos(N);
        fSize := N
    end;

    procedure TTextFile.SetFilePos (N: longint);
        OVERRIDE;
    begin
        if fBuffer <> nil then
            fPos := min(N, fSize)
        else
            inherited SetFilePos(N);
    end;

    procedure TTextFile.GetFilePos (var N: longint);
        OVERRIDE;
    begin
        if fBuffer <> nil then
            N := fPos
        else
            inherited GetFilePos(N);
    end;


    procedure TRecordFile.IRecordFile (RefNum, RecSiz: integer);
    begin
        IGenericFile(RefNum);
        fRecSize := RecSiz;
        FailOSErr(fSize mod fRecSize);    {File size must be a multiple of record size}
    end;

    procedure TRecordFile.Seek (N: longint);
    begin
        SetFilePos(N * fRecSize);
    end;

    procedure TRecordFile.ReadRec (addr: ptr);
        var
            N: longint;
    begin
        N := fRecSize;
        FailOSErr(FSRead(fRef, N, addr));
        fPos := fPos + N
    end;

    procedure TRecordFile.WriteRec (addr: ptr);
        var
            N: longint;
    begin
        N := fRecSize;
        FailOSErr(FSWrite(fRef, N, addr));
        if EndOfFile then
            fSize := fSize + N;
        fPos := fPos + N
    end;

{$S AFields}
    procedure TGenericFile.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: INTEGER));
        OVERRIDE;
    begin
        DoToField('TGenericFile', nil, bClass);
        DoToField('fRef', @fRef, bINTEGER);
        DoToField('fSize', @fSize, bLongint);
        DoToField('fPos', @fPos, bLongint);
        inherited Fields(DoToField);
    end;

    procedure TTextFile.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: INTEGER));
        OVERRIDE;
    begin
        DoToField('TTextFile', nil, bClass);
        DoToField('fBuffer', @fBuffer, bHandle);
        inherited Fields(DoToField);
    end;

    procedure TRecordFile.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: INTEGER));
        OVERRIDE;
    begin
        DoToField('TRecordFile', nil, bClass);
        DoToField('fRecSize', @fRecSize, bLongint);
        inherited Fields(DoToField);
    end;

end.